home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / maintenance.lisp < prev    next >
Encoding:
Text File  |  1991-10-21  |  6.7 KB  |  176 lines
  1. ;;; -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                System Maintenance
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: maintenance.lisp,v 1.1 1991/10/21 15:28:04 rz Exp $
  8.  
  9. (in-package "USER")
  10.  
  11. (defun load-weyl-version ()
  12.   (cond ((probe-file *weyl-version-file*)
  13.      (load *weyl-version-file* :verbose nil))
  14.     (t (setq *weyl-version* (list 1 0)))))
  15.  
  16. (defun dump-weyl-version ()
  17.   (with-open-file (file *weyl-version-file*
  18.             :direction :output
  19.             :if-exists :supersede)
  20.     (format file ";; Weyl version ~D.~D~%~
  21.                   (in-package \"USER\")~
  22.                   (setq *weyl-version* (list ~D ~D))~3%"
  23.         (first *weyl-version*) (second *weyl-version*)
  24.         (first *weyl-version*) (second *weyl-version*))))
  25.  
  26. (defun next-major-weyl-version ()
  27.   (load-weyl-version)
  28.   (incf (first *weyl-version*))
  29.   (setf (second *weyl-version*) 0)
  30.   (dump-weyl-version))
  31.  
  32. (defun next-minor-weyl-version ()
  33.   (load-weyl-version)
  34.   (incf (second *weyl-version*))
  35.   (dump-weyl-version))
  36.  
  37. (defun load-weyl ()
  38.   (defsys::load-system 'weyl)
  39.   (load-weyl-version)
  40.   (pushnew :weyl *features*)
  41.   (funcall (intern "RESET-DOMAINS" 'weyli))
  42.   (funcall (intern "INITIALIZE-CONTEXTS" 'weyli))
  43.   (format t ";;; Weyl ~D.~D loaded. ~%"
  44.       (first *weyl-version*) (second *weyl-version*))
  45.   (values))
  46.  
  47. (defun compile-weyl ()
  48.   (flet ((compile-if-necessary (file)
  49.        (let ((src (make-pathname
  50.                :name file
  51.                :type (first (eval (intern "*SUFFIXES*" 'defsys)))
  52.                :device (pathname-device *weyl-directory*)
  53.                :directory (pathname-directory *weyl-directory*)))
  54.          (obj (make-pathname
  55.                :name file
  56.                :type (rest (eval (intern "*SUFFIXES*" 'defsys)))
  57.                :device (pathname-device *weyl-directory*)
  58.                :directory (pathname-directory *weyl-directory*))))
  59.          (when (or (not (probe-file obj))
  60.                (> (file-write-date src) (file-write-date obj)))
  61.            (compile-file src)
  62.            (load obj)))))
  63.     (compile-if-necessary "sysdef")
  64.     (compile-if-necessary "defsystem")
  65.     (compile-if-necessary "maintenance")
  66.     (defsys:compile-system 'weyl)
  67.     (next-minor-weyl-version)))
  68.  
  69. #+Lucid
  70. (defun dump-weyl (&optional (name "weyl"))
  71.   (load-weyl)
  72.   (multiple-value-bind (seconds minutes hour date month year d-o-w d-s-t t-z)
  73.       (decode-universal-time (get-universal-time))
  74.     (declare (ignore seconds minutes hour d-o-w d-s-t t-z))
  75.     (let ((file (make-pathname
  76.          :name #+MIPS "weyl-mips"
  77.                #+SUN4 "weyl-sun4"
  78.          :directory (pathname-directory *weyl-directory*)))
  79.       (archive (format nil
  80.                #+MIPS "~A/~A-mips-~D-~D-~D-~D"
  81.                #+SUN4 "~A/~A-sun4-~D-~D-~D-~D"
  82.                *weyl-archive-directory*
  83.                name month date year
  84.                (+ minutes (* 100 hour))))
  85.       (banner (weyl-banner)))
  86.       (declare (special system::*enter-top-level-hook*))
  87.       (when (probe-file file)
  88.     (delete-file file))
  89.       (user::shell (format nil "ln -s ~A ~A" archive file))
  90.       (setq system::*enter-top-level-hook* 
  91.         #'(lambda ()
  92.         (format t ";;; ~A~2%"  banner)
  93.         (lucid::default-enter-top-level-hook)))
  94.       (disksave file :full-gc t)
  95.       (format t ";;; Weyl ~D.~D successfully dumped into ~A~%~
  96.                  ;;; and link was created to it from ~A" 
  97.           (first *weyl-version*) (second *weyl-version*)
  98.           archive file))))
  99.  
  100. (defun weyl-banner ()
  101.   (multiple-value-bind (second minute hour date month year day-of-week)
  102.       (decode-universal-time (get-universal-time))
  103.     (declare (ignore second))
  104.     (format nil "Weyl Version ~D.~D, saved ~2D:~2D ~A, ~A ~D, ~D"
  105.         (first *weyl-version*) (second *weyl-version*)
  106.         hour minute
  107.         (second (assoc day-of-week
  108.                '((0 "Monday") (1 "Tuesday") (2 "Wednesday")
  109.                  (3 "Thursday") (4 "Friday") (5 "Saturday")
  110.                  (6 "Sunday"))))
  111.         (second (assoc month
  112.                '((1 "January") (2 "February") (3 "March")
  113.                  (4 "April") (5 "May") (6 "June") (7 "July")
  114.                  (8 "August") (9 "September") (10 "October")
  115.                  (11 "November") (12 "December"))))
  116.         date
  117.         year)))
  118.  
  119. (defsys:defsystem weyl
  120.     (:default-pathname #.*weyl-directory*
  121.      :default-package weyl)
  122.   #-(or CMU Allegro)
  123.   walk
  124.   #+(or CMU Allegro)
  125.   lisp-support
  126.   #-(or CMU Allegro)
  127.   (lisp-support :load-after (walk))
  128.   (domain-support :load-before-compile (lisp-support))
  129.   (algebraic-domains :load-before-compile (lisp-support domain-support))
  130.   (general :load-before-compile (lisp-support domain-support algebraic-domains))
  131.   (sets :load-before-compile (lisp-support domain-support algebraic-domains))
  132.   (direct-sums :load-before-compile (lisp-support domain-support algebraic-domains sets))
  133.   (lisp-numbers :load-before-compile
  134.         (lisp-support domain-support algebraic-domains))
  135.   (avl :load-before-compile (lisp-support domain-support algebraic-domains))
  136.   (rational-integers :load-before-compile
  137.              (lisp-support domain-support algebraic-domains))
  138.   (gfp :load-before-compile (lisp-support domain-support lisp-numbers algebraic-domains))
  139.   (bigfloat :load-before-compile
  140.         (lisp-support domain-support algebraic-domains))
  141.   (quotient-fields :load-before-compile
  142.            (lisp-support domain-support general algebraic-domains))
  143.   (rational-numbers :load-before-compile
  144.             (lisp-support domain-support algebraic-domains quotient-fields))
  145.   (poly-tools :load-before-compile
  146.           (lisp-support domain-support general algebraic-domains))
  147.   (mpolynomial :load-before-compile
  148.            (lisp-support domain-support general algebraic-domains))
  149.   (upolynomial :load-before-compile
  150.            (lisp-support domain-support algebraic-domains))  
  151.   (epolynomial :load-before-compile
  152.            (lisp-support domain-support algebraic-domains mpolynomial))
  153.   (grobner :load-before-compile       
  154.            (lisp-support domain-support algebraic-domains mpolynomial))
  155.   (rational-functions :load-before-compile
  156.               (lisp-support domain-support general algebraic-domains 
  157.                     quotient-fields))
  158.   (morphisms :load-before-compile
  159.          (lisp-support domain-support algebraic-domains mpolynomial))
  160.   (differential-domains :load-before-compile
  161.                         (lisp-support domain-support general algebraic-domains
  162.                       mpolynomial))
  163.   (algebraic-extension :load-before-compile
  164.                (lisp-support domain-support general algebraic-domains
  165.                      mpolynomial))
  166.   (coercions :load-before-compile
  167.          (lisp-support domain-support algebraic-domains))
  168.   (vector :load-before-compile (lisp-support domain-support algebraic-domains sets))
  169.   (projective-space :load-before-compile
  170.             (lisp-support domain-support algebraic-domains vector))
  171.   (quaternions :load-before-compile
  172.            (lisp-support domain-support algebraic-domains sets vector))
  173.   (matrix :load-before-compile
  174.       (lisp-support domain-support algebraic-domains)))
  175.  
  176.